home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / mint / editors / mntemacs.zoo / src / fns.c < prev    next >
C/C++ Source or Header  |  1991-12-02  |  34KB  |  1,381 lines
  1. /* Random utility Lisp functions.
  2.    Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
  3.  
  4. This file is part of GNU Emacs.
  5.  
  6. GNU Emacs is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GNU Emacs is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GNU Emacs; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20.  
  21. #include "config.h"
  22.  
  23. #ifdef LOAD_AVE_TYPE
  24. #ifdef BSD
  25. /* It appears param.h defines BSD and BSD4_3 in 4.3
  26.    and is not considerate enough to avoid bombing out
  27.    if they are already defined.  */
  28. #undef BSD
  29. #ifdef BSD4_3
  30. #undef BSD4_3
  31. #define XBSD4_3 /* XBSD4_3 says BSD4_3 is supposed to be defined.  */
  32. #endif
  33. #include <sys/param.h>
  34. /* Now if BSD or BSD4_3 was defined and is no longer,
  35.    define it again.  */
  36. #ifndef BSD
  37. #define BSD
  38. #endif
  39. #ifdef XBSD4_3
  40. #ifndef BSD4_3
  41. #define BSD4_3
  42. #endif
  43. #endif /* XBSD4_3 */
  44. #endif /* BSD */
  45. #ifndef VMS
  46. #ifndef NLIST_STRUCT
  47. #include <a.out.h> 
  48. #else /* NLIST_STRUCT */
  49. #include <nlist.h>
  50. #endif /* NLIST_STRUCT */
  51. #endif /* not VMS */
  52. #endif /* LOAD_AVE_TYPE */
  53.  
  54. /* Note on some machines this defines `vector' as a typedef,
  55.    so make sure we don't use that name in this file.  */
  56. #undef vector
  57. #define vector *****
  58.  
  59. #ifdef NULL
  60. #undef NULL
  61. #endif
  62. #include "lisp.h"
  63. #include "commands.h"
  64.  
  65. #ifdef lint
  66. #include "buffer.h"
  67. #endif /* lint */
  68.  
  69. Lisp_Object Qstring_lessp;
  70.  
  71. DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
  72.   "Return the argument unchanged.")
  73.   (arg)
  74.      Lisp_Object arg;
  75. {
  76.   return arg;
  77. }
  78.  
  79. DEFUN ("random", Frandom, Srandom, 0, 1, 0,
  80.   "Return a pseudo-random number.\n\
  81. On most systems all integers representable in Lisp are equally likely.\n\
  82.   This is 24 bits' worth.\n\
  83. On some systems, absolute value of result never exceeds 2 to the 14.\n\
  84. If optional argument is supplied as  t,\n\
  85.  the random number seed is set based on the current time and pid.")
  86.   (arg)
  87.      Lisp_Object arg;
  88. {
  89.   extern long random ();
  90.   extern srandom ();
  91.   extern long time ();
  92.  
  93.   if (EQ (arg, Qt))
  94.     srandom (getpid () + time (0));
  95.   return make_number ((int) random ());
  96. }
  97.  
  98. /* Random data-structure functions */
  99.  
  100. DEFUN ("length", Flength, Slength, 1, 1, 0,
  101.   "Return the length of vector, list or string SEQUENCE.")
  102.   (obj)
  103.      register Lisp_Object obj;
  104. {
  105.   register Lisp_Object tail, val;
  106.   register int i;
  107.  
  108.  retry:
  109.   if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
  110.     return Farray_length (obj);
  111.   else if (CONSP (obj))
  112.     {
  113.       for (i = 0, tail = obj; !NULL(tail); i++)
  114.     {
  115.       QUIT;
  116.       tail = Fcdr (tail);
  117.     }
  118.  
  119.       XFASTINT (val) = i;
  120.       return val;
  121.     }
  122.   else if (NULL(obj))
  123.     {
  124.       XFASTINT (val) = 0;
  125.       return val;
  126.     }
  127.   else
  128.     {
  129.       obj = wrong_type_argument (Qsequencep, obj);
  130.       goto retry;
  131.     }
  132. }
  133.  
  134. DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
  135.   "T if two strings have identical contents.\n\
  136. Symbols are also allowed; their print names are used instead.")
  137.   (s1, s2)
  138.      register Lisp_Object s1, s2;
  139. {
  140.   if (XTYPE (s1) == Lisp_Symbol)
  141.     XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
  142.   if (XTYPE (s2) == Lisp_Symbol)
  143.     XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
  144.   CHECK_STRING (s1, 0);
  145.   CHECK_STRING (s2, 1);
  146.  
  147.   if (XSTRING (s1)->size != XSTRING (s2)->size ||
  148.       bcmp (XSTRING (s1)->data, XSTRING (s2)->data, XSTRING (s1)->size))
  149.     return Qnil;
  150.   return Qt;
  151. }
  152.  
  153. DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
  154.   "T if first arg string is less than second in lexicographic order.\n\
  155. Symbols are also allowed; their print names are used instead.")
  156.   (s1, s2)
  157.      register Lisp_Object s1, s2;
  158. {
  159.   register int i;
  160.   register unsigned char *p1, *p2;
  161.   register int end;
  162.  
  163.   if (XTYPE (s1) == Lisp_Symbol)
  164.     XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
  165.   if (XTYPE (s2) == Lisp_Symbol)
  166.     XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
  167.   CHECK_STRING (s1, 0);
  168.   CHECK_STRING (s2, 1);
  169.  
  170.   p1 = XSTRING (s1)->data;
  171.   p2 = XSTRING (s2)->data;
  172.   end = XSTRING (s1)->size;
  173.   if (end > XSTRING (s2)->size)
  174.     end = XSTRING (s2)->size;
  175.  
  176.   for (i = 0; i < end; i++)
  177.     {
  178.       if (p1[i] != p2[i])
  179.     return p1[i] < p2[i] ? Qt : Qnil;
  180.     }
  181.   return i < XSTRING (s2)->size ? Qt : Qnil;
  182. }
  183.  
  184. static Lisp_Object concat ();
  185.  
  186. /* ARGSUSED */
  187. Lisp_Object
  188. concat2 (s1, s2)
  189.      Lisp_Object s1, s2;
  190. {
  191. #ifdef NO_ARG_ARRAY
  192.   Lisp_Object args[2];
  193.   args[0] = s1;
  194.   args[1] = s2;
  195.   return concat (2, args, Lisp_String, 0);
  196. #else
  197.   return concat (2, &s1, Lisp_String, 0);
  198. #endif /* NO_ARG_ARRAY */
  199. }
  200.  
  201. DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
  202.   "Concatenate arguments and make the result a list.\n\
  203. The result is a list whose elements are the elements of all the arguments.\n\
  204. Each argument may be a list, vector or string.")
  205.   (nargs, args)
  206.      int nargs;
  207.      Lisp_Object *args;
  208. {
  209.   return concat (nargs, args, Lisp_Cons, 1);
  210. }
  211.  
  212. DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
  213.   "Concatenate arguments and make the result a string.\n\
  214. The result is a string whose elements are the elements of all the arguments.\n\
  215. Each argument may be a string, a list of numbers, or a vector of numbers.")
  216.   (nargs, args)
  217.      int nargs;
  218.      Lisp_Object *args;
  219. {
  220.   return concat (nargs, args, Lisp_String, 0);
  221. }
  222.  
  223. DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
  224.   "Concatenate arguments and make the result a vector.\n\
  225. The result is a vector whose elements are the elements of all the arguments.\n\
  226. Each argument may be a list, vector or string.")
  227.   (nargs, args)
  228.      int nargs;
  229.      Lisp_Object *args;
  230. {
  231.   return concat (nargs, args, Lisp_Vector, 0);
  232. }
  233.  
  234. DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
  235.   "Return a copy of a list, vector or string.")
  236.   (arg)
  237.      Lisp_Object arg;
  238. {
  239.   if (NULL (arg)) return arg;
  240.   if (!CONSP (arg) && XTYPE (arg) != Lisp_Vector && XTYPE (arg) != Lisp_String)
  241.     arg = wrong_type_argument (Qsequencep, arg);
  242.   return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
  243. }
  244.  
  245. static Lisp_Object
  246. concat (nargs, args, target_type, last_special)
  247.      int nargs;
  248.      Lisp_Object *args;
  249.      enum Lisp_Type target_type;
  250.      int last_special;
  251. {
  252.   Lisp_Object val;
  253.   Lisp_Object len;
  254.   register Lisp_Object tail;
  255.   register Lisp_Object this;
  256.   int toindex;
  257.   register int leni;
  258.   register int argnum;
  259.   Lisp_Object last_tail;
  260.   Lisp_Object prev;
  261.  
  262.   /* In append, the last arg isn't treated like the others */
  263.   if (last_special && nargs > 0)
  264.     {
  265.       nargs--;
  266.       last_tail = args[nargs];
  267.     }
  268.   else
  269.     last_tail = Qnil;
  270.  
  271.   for (argnum = 0; argnum < nargs; argnum++)
  272.     {
  273.       this = args[argnum];
  274.       if (!(CONSP (this) || NULL (this)
  275.           || XTYPE (this) == Lisp_Vector || XTYPE (this) == Lisp_String))
  276.     {
  277.       if (XTYPE (this) == Lisp_Int)
  278.             args[argnum] = Fint_to_string (this);
  279.       else
  280.         args[argnum] = wrong_type_argument (Qsequencep, this);
  281.     }
  282.     }
  283.  
  284.   for (argnum = 0, leni = 0; argnum < nargs; argnum++)
  285.     {
  286.       this = args[argnum];
  287.       len = Flength (this);
  288.       leni += XFASTINT (len);
  289.     }
  290.  
  291.   XFASTINT (len) = leni;
  292.  
  293.   if (target_type == Lisp_Cons)
  294.     val = Fmake_list (len, Qnil);
  295.   else if (target_type == Lisp_Vector)
  296.     val = Fmake_vector (len, Qnil);
  297.   else
  298.     val = Fmake_string (len, len);
  299.  
  300.   /* In append, if all but last arg are nil, return last arg */
  301.   if (target_type == Lisp_Cons && EQ (val, Qnil))
  302.     return last_tail;
  303.  
  304.   if (CONSP (val))
  305.     tail = val, toindex = -1;        /* -1 in toindex is flag we are making a list */
  306.   else
  307.     toindex = 0;
  308.  
  309.   prev = Qnil;
  310.  
  311.   for (argnum = 0; argnum < nargs; argnum++)
  312.     {
  313.       Lisp_Object thislen;
  314.       int thisleni;
  315.       register int thisindex = 0;
  316.  
  317.       this = args[argnum];
  318.       if (!CONSP (this))
  319.     thislen = Flength (this), thisleni = XINT (thislen);
  320.  
  321.